PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/cert/trk3_eg/fmdrgdrp/opt2/invent.exe/DBS.BAS

BASIC Source File | 1993-08-20 | 5.4 KB | 229 lines

' Array to hold database forms

Const MAX_DBS = 3
Global DbsFormItems(MAX_DBS) As FormItem
Global DbsForms(MAX_DBS) As DbsForm
Global DbsFormDatabase(MAX_DBS) As Database

' Schema type definition

Type TABLESCHEMA
    tsName As String
    tsType As Integer
    tsSize As Integer
End Type

' Table extensions

Global Const TEX_CUSTS = "@cust"
Global Const TEX_PARTS = "@part"
Global Const TEX_ORDERS = "@ord"

Sub AppendField (tsc As TABLESCHEMA, newt As TableDef)

    ' Append a field to the evolving TableDef

    Dim newf As New Field
    newf.Name = tsc.tsName
    newf.Type = tsc.tsType
    If tsc.tsSize Then newf.Size = tsc.tsSize
    newt.Fields.Append newf

End Sub

Sub DbsCreate ()

    ' Create a DBS form by creating a new Access
    ' Database.  Tables will be put into it later by
    ' the user.

    If Not FormAvail(DbsFormItems()) Then
        MsgBox "Cannot open more database forms"
        Exit Sub
    End If
    fname$ = UtilsNewFile("New", "Database", "inv")
    If fname$ = "" Then Exit Sub
    i% = FormAlloc(DbsFormItems())
    DbsFormItems(i%).fiFileName = fname$

    ' Now, create the database

    On Error GoTo dbcfail
    Dim newdb As Database
    Set newdb = CreateDatabase(fname$, DB_LANG_GENERAL)
    DbsFormItems(i%).fiFileName = fname$
    newdb.Close
    Set DbsForms(i%) = New DbsForm
    DbsForms(i%).Show
    DbsForms(i%).Caption = fname$

    Exit Sub

dbcfail:
    FormFree DbsFormItems(i%)
    Exit Sub
End Sub

Sub DbsDeleteTable ()
    Dim formdb As Database

    ' This routine must always be called while a DBS
    ' form is visible and there is a current table.
    ' It deletes the specified table and all of its data.

    findex% = Val(MDIMain.ActiveForm.Tag)

    tbname$ = DbsFormItems(findex%).fiTable
    Set formdb = DbsFormDatabase(findex%)

    ' Ask the user if they're sure before continuing

    ret% = MsgBox("Delete " & TnameDisp(tbname$) & " and all of its data?", MB_OKCANCEL Or MB_ICONEXCLAMATION)
    If ret% <> IDOK Then Exit Sub

    ' Remove the table

    formdb.TableDefs.Delete tbname$

    ' Hack to cause DBS form to refresh

    MDIMain.ActiveForm.LoadRowCmd.Value = True

End Sub

Sub DbsNewTable ()

    ' Depending upon the type, pass the schema to the
    ' NewTable routine for actual table creation

    DialogParm = ExtractFile(MDIMain.ActiveForm.Caption)
    NewForm.Show MODAL
    If Not DialogCancel Then
        Select Case DialogParm
            Case ID_NEW_PARTS
                NewTable (DialogParm2) + TEX_PARTS, PartsSchema()
            Case ID_NEW_CUST
                NewTable (DialogParm2) + TEX_CUSTS, CustSchema()
            Case ID_NEW_OBROWSE
                NewTable (DialogParm2) + TEX_ORDERS, OBrowseSchema()
        End Select
    End If

End Sub

Sub DbsOpen (fname As String)

    ' Open an existing table

    If Not FormAvail(DbsFormItems()) Then
        MsgBox "Cannot open more database forms"
        Exit Sub
    End If

    i% = FormAlloc(DbsFormItems())
    DbsFormItems(i%).fiFileName = fname

    ' Try to open the file

    On Error GoTo dbofail
    Dim newdb As Database
    Set newdb = OpenDatabase(fname)
    newdb.Close

    Set DbsForms(i%) = New DbsForm
    DbsForms(i%).Show
    DbsForms(i%).Caption = fname
    Exit Sub

dbofail:
    FormFree DbsFormItems(i%)
    Exit Sub

End Sub

Sub DbsOpenCurrentTable (findex As Integer)

    ' Open the table which is currently pointed to in
    ' the opened DBS form

    fn$ = DbsFormItems(findex).fiFileName
    tbn$ = DbsFormItems(findex).fiTable
    Select Case TnameType(tbn$)
        Case TEX_PARTS
            PartsOpen fn$, tbn$
        Case TEX_CUSTS
            CustOpen fn$, tbn$
        Case TEX_ORDERS
            OBrowseOpen fn$, tbn$
    End Select

End Sub

Sub InitDbs ()
    FormInit DbsFormItems()
End Sub

Sub NewTable (newname As String, tsch() As TABLESCHEMA)

    ' Generic routine to create a new table within the
    ' database presented in the ActiveForm

    Dim newt As New TableDef

    Screen.MousePointer = HOURGLASS
    SetStatus "Creating " & TnameDisp(newname) & " ..."

    For i% = 1 To UBound(tsch)
        AppendField tsch(i%), newt
    Next i%
    Dim formdb As Database
    Set formdb = DbsFormDatabase(Val(MDIMain.ActiveForm.Tag))
    newt.Name = newname
    formdb.TableDefs.Append newt

    Screen.MousePointer = DEFAULT

    MDIMain.ActiveForm.LoadRowCmd.Value = True
End Sub

Function TnameDisp (tname As String)

    ' Strips our internal table suffix for proper display.

    i% = InStr(tname, "@")
    If i% Then
        TnameDisp = Left$(tname, i% - 1)
    Else
        TnameDisp = tname
    End If
End Function

Function TnameType (tname As String)

    ' Returns the type of a table by checking our suffix

    i% = InStr(tname, "@")
    If i% Then
        TnameType = Mid$(tname, i%)
    Else
        TnameType = "???"
    End If
End Function

Function TnameTypeDisp (tname As String)

    ' From our table suffix, returns a laymans term
    ' for the table type

    Select Case TnameType(tname)
        Case TEX_CUSTS
            TnameTypeDisp = "Customers"
        Case TEX_PARTS
            TnameTypeDisp = "Parts"
        Case TEX_ORDERS
            TnameTypeDisp = "Orders"
    End Select

End Function